;; Copyright (c) [2022] [bobwxc]
;; This file is licensed under Mulan PubL v2.
;; You can use this software according to the terms and conditions of the Mulan PubL v2.
;; You may obtain a copy of Mulan PubL v2 at:
;;          http://license.coscl.org.cn/MulanPubL-2.0
;; THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OF ANY KIND,
;; EITHER EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO NON-INFRINGEMENT,
;; MERCHANTABILITY OR FIT FOR A PARTICULAR PURPOSE.
;; See the Mulan PubL v2 for more details.

;; Murmur Hash 3
;; - x86-32
;; - x86-128
;; - x64-128

;; This a single file format library for simple `require` use.

(defpackage #:cl-murmurhash-3
  (:nicknames #:murmur3 #:mr3)
  (:use #:cl)
  (:export #:murmur3-x86-32
           #:murmur3-x86-128
           #:murmur3-x64-128))

(in-package #:cl-murmurhash-3)

(defun rotl32 (x r)
  (declare ((unsigned-byte 32) x)
           ((unsigned-byte 8) r))
  (mod (logior (ash x r) (ash x (- r 32))) #16r100000000))

(defun rotl64 (x r)
  (declare ((unsigned-byte 64) x)
           ((unsigned-byte 8) r))
  (mod (logior (ash x r) (ash x (- r 64))) #16r10000000000000000))

(defun fmix32 (h)
  (declare ((unsigned-byte 32) h))
  (let* ((i (logxor h (ash h -16)))
         (j (mod (* i #16r86ebca6b) #16r100000000))
         (k (logxor j (ash j -13)))
         (l (mod (* k #16rc2b2ae35) #16r100000000))
         (m (logxor l (ash l -16))))
    (declare ((unsigned-byte 32) i j k l m))
    m))

(defun fmix64 (h)
  (declare ((unsigned-byte 64) h))
  (let* ((i (logxor h (ash h -33)))
         (j (mod (* i #16rff51afd7ed558ccd) #16r10000000000000000))
         (k (logxor j (ash j -33)))
         (l (mod (* k #16rc4ceb9fe1a85ec53) #16r10000000000000000))
         (m (logxor l (ash l -33))))
    (declare ((unsigned-byte 64) i j k l m))
    m))

(defun fourbytes (lst n)
  (if (find :little-endian cl:*features*)
      (mod (+ (nth n lst) ;; little-endian
              (ash (nth (+ n 1) lst) 8)
              (ash (nth (+ n 2) lst) 16)
              (ash (nth (+ n 3) lst) 24))
           #16r100000000)
    (mod (+ (ash (nth n lst) 24) ;; big-endian
            (ash (nth (+ n 1) lst) 16)
            (ash (nth (+ n 2) lst) 8)
            (nth (+ n 3) lst))
         #16r100000000)))

(defun eightbytes (lst n)
  (if (find :little-endian cl:*features*)
      (mod (+ (nth n lst) ;; little-endian
              (ash (nth (+ n 1) lst) 8)
              (ash (nth (+ n 2) lst) 16)
              (ash (nth (+ n 3) lst) 24)
              (ash (nth (+ n 4) lst) 32)
              (ash (nth (+ n 5) lst) 40)
              (ash (nth (+ n 6) lst) 48)
              (ash (nth (+ n 7) lst) 56))
           #16r10000000000000000)
    (mod (+ (ash (nth n lst) 56) ;; big-endian
            (ash (nth (+ n 1) lst) 48)
            (ash (nth (+ n 2) lst) 40)
            (ash (nth (+ n 3) lst) 32)
            (ash (nth (+ n 4) lst) 24)
            (ash (nth (+ n 5) lst) 16)
            (ash (nth (+ n 6) lst) 8)
            (nth (+ n 7) lst))
         #16r10000000000000000)))

(defun murmur3-x86-32 (data &optional (seed 0))
  (declare (list data) ;; list of '(unsigned-byte 8)
           ((unsigned-byte 32) seed))
  (let ((h1 seed)
        (c1 #16rcc9e2d51)
        (c2 #16r1b873593)
        (nblock (floor (/ (length data) 4)))
        (len (length data)))
    (declare ((unsigned-byte 32) h1))
    ;; body
    (loop for i from 0 to (- nblock 1)
          do(let ((k1 (fourbytes data (* i 4))))
              (setf k1 (rotl32 (mod (* k1 c1) #16r100000000) 15))
              (setf k1 (mod (* k1 c2) #16r100000000))
              (setf h1 (rotl32 (logxor h1 k1) 13))
              (setf h1 (mod (+ (* h1 5) #16re6546b64) #16r100000000))))
    ;; tail
    (let ((k1 0)
          (nb (* nblock 4)))
      (if (find :little-endian cl:*features*)
          (cond ;; little-endian
           ((= (mod len 4) 3)
            (setf k1 (logxor (nth nb data)
                             (ash (nth (+ nb 1) data) 8)
                             (ash (nth (+ nb 2) data) 16)
                             k1)))
           ((= (mod len 4) 2)
            (setf k1 (logxor (nth nb data)
                             (ash (nth (+ nb 1) data) 8)
                             k1)))
           ((= (mod len 4) 1)
            (setf k1 (logxor (nth nb data)
                             k1))))
        (cond ;; big-endian
         ((= (mod len 4) 3)
          (setf k1 (logxor (ash (nth nb data) 16)
                           (ash (nth (+ nb 1) data) 8)
                           (nth (+ nb 2) data)
                           k1)))
         ((= (mod len 4) 2)
          (setf k1 (logxor (ash (nth nb data) 8)
                           (nth (+ nb 1) data)
                           k1)))
         ((= (mod len 4) 1)
          (setf k1 (logxor (nth nb data)
                           k1)))))
      (when (/= (mod len 4) 0)
        (setf k1 (rotl32 (mod (* k1 c1) #16r100000000) 15))
        (setf k1 (mod (* k1 c2) #16r100000000))
        (setf h1 (logxor h1 k1))))
    ;; finalization
    (setf h1 (fmix32 (logxor h1 len)))
    ;; return
    h1))

(defun murmur3-x86-128 (data &optional (seed 0))
  (declare (list data) ;; list of '(unsigned-byte 8)
           ((unsigned-byte 32) seed))
  (let ((h1 seed)
        (h2 seed)
        (h3 seed)
        (h4 seed)
        (c1 #16r239b961b)
        (c2 #16rab0e9789)
        (c3 #16r38b34ae5)
        (c4 #16ra1e38b93)
        (nblock (floor (/ (length data) 16))) ;; 128 bits = 16 bytes
        (len (length data)))
    (declare ((unsigned-byte 32) h1 h2 h3 h4))
    ;; body
    (loop for i from 0 to (- nblock 1)
          do(let ((k1 (fourbytes data (* i 16)))
                  (k2 (fourbytes data (+ (* i 16) 4)))
                  (k3 (fourbytes data (+ (* i 16) 8)))
                  (k4 (fourbytes data (+ (* i 16) 12)))
                  )
              (setf k1 (rotl32 (mod (* k1 c1) #16r100000000) 15))
              (setf k1 (mod (* k1 c2) #16r100000000))
              (setf h1 (mod (+ (rotl32 (logxor h1 k1) 19) h2) #16r100000000))
              (setf h1 (mod (+ (* h1 5) #16r561ccd1b) #16r100000000))
              
              (setf k2 (rotl32 (mod (* k2 c2) #16r100000000) 16))
              (setf k2 (mod (* k2 c3) #16r100000000))
              (setf h2 (mod (+ (rotl32 (logxor h2 k2) 17) h3) #16r100000000))
              (setf h2 (mod (+ (* h2 5) #16r0bcaa747) #16r100000000))

              (setf k3 (rotl32 (mod (* k3 c3) #16r100000000) 17))
              (setf k3 (mod (* k3 c4) #16r100000000))
              (setf h3 (mod (+ (rotl32 (logxor h3 k3) 15) h4) #16r100000000))
              (setf h3 (mod (+ (* h3 5) #16r96cd1c35) #16r100000000))

              (setf k4 (rotl32 (mod (* k4 c4) #16r100000000) 18))
              (setf k4 (mod (* k4 c1) #16r100000000))
              (setf h4 (mod (+ (rotl32 (logxor h4 k4) 13) h1) #16r100000000))
              (setf h4 (mod (+ (* h4 5) #16r32ac3b17) #16r100000000))
              ))
    ;; tail
    (let ((k1 0)
          (k2 0)
          (k3 0)
          (k4 0)
          (kk 0)
          (nb (* nblock 16))
          (nr (floor (/ (mod len 16) 4)))
          (rr (mod len 4))
          )
      (cond ;; rest 0f mod 16
       ((= nr 3)
        (setf k1 (fourbytes data nb))
        (setf k2 (fourbytes data (+ nb 4)))
        (setf k3 (fourbytes data (+ nb 8))))
       ((= nr 2)
        (setf k1 (fourbytes data nb))
        (setf k2 (fourbytes data (+ nb 4))))
       ((= nr 1)
        (setf k1 (fourbytes data nb)))
       )
      (if (find :little-endian cl:*features*) ;; rest of mod 4
          (cond ;; little-endian
           ((= (mod len 4) 3)
            (setf kk (logxor (nth (+ nb (* nr 4)) data)
                             (ash (nth (+ (+ nb (* nr 4)) 1) data) 8)
                             (ash (nth (+ (+ nb (* nr 4)) 2) data) 16)
                             kk)))
           ((= (mod len 4) 2)
            (setf kk (logxor (nth (+ nb (* nr 4)) data)
                             (ash (nth (+ (+ nb (* nr 4)) 1) data) 8)
                             kk)))
           ((= (mod len 4) 1)
            (setf kk (logxor (nth (+ nb (* nr 4)) data)
                             kk))))
        (cond ;; big-endian
         ((= (mod len 4) 3)
          (setf kk (logxor (ash (nth (+ nb (* nr 4)) data) 16)
                           (ash (nth (+ (+ nb (* nr 4)) 1) data) 8)
                           (nth (+ (+ nb (* nr 4)) 2) data)
                           kk)))
         ((= (mod len 4) 2)
          (setf kk (logxor (ash (nth (+ nb (* nr 4)) data) 8)
                           (nth (+ (+ nb (* nr 4)) 1) data)
                           kk)))
         ((= (mod len 4) 1)
          (setf kk (logxor (nth (+ nb (* nr 4)) data)
                           kk)))))
      (cond
       ((= nr 3)
        (when (/= rr 0) 
          (setf k4 kk)
          (setf k4 (rotl32 (mod (* k4 c4) #16r100000000) 18))
          (setf k4 (mod (* k4 c1) #16r100000000))
          (setf h4 (logxor h4 k4)))
        (setf k3 (rotl32 (mod (* k3 c3) #16r100000000) 17))
        (setf k3 (mod (* k3 c4) #16r100000000))
        (setf h3 (logxor h3 k3))
        (setf k2 (rotl32 (mod (* k2 c2) #16r100000000) 16))
        (setf k2 (mod (* k2 c3) #16r100000000))
        (setf h2 (logxor h2 k2))
        (setf k1 (rotl32 (mod (* k1 c1) #16r100000000) 15))
        (setf k1 (mod (* k1 c2) #16r100000000))
        (setf h1 (logxor h1 k1)))
       ((= nr 2)
        (when (/= rr 0) 
          (setf k3 kk)
          (setf k3 (rotl32 (mod (* k3 c3) #16r100000000) 17))
          (setf k3 (mod (* k3 c4) #16r100000000))
          (setf h3 (logxor h3 k3)))
        (setf k2 (rotl32 (mod (* k2 c2) #16r100000000) 16))
        (setf k2 (mod (* k2 c3) #16r100000000))
        (setf h2 (logxor h2 k2))
        (setf k1 (rotl32 (mod (* k1 c1) #16r100000000) 15))
        (setf k1 (mod (* k1 c2) #16r100000000))
        (setf h1 (logxor h1 k1)))
       ((= nr 1)
        (when (/= rr 0) 
          (setf k2 kk)
          (setf k2 (rotl32 (mod (* k2 c2) #16r100000000) 16))
          (setf k2 (mod (* k2 c3) #16r100000000))
          (setf h2 (logxor h2 k2)))
        (setf k1 (rotl32 (mod (* k1 c1) #16r100000000) 15))
        (setf k1 (mod (* k1 c2) #16r100000000))
        (setf h1 (logxor h1 k1)))
       ((= nr 0)
        (when (/= rr 0) 
          (setf k1 kk)
          (setf k1 (rotl32 (mod (* k1 c1) #16r100000000) 15))
          (setf k1 (mod (* k1 c2) #16r100000000))
          (setf h1 (logxor h1 k1))))))
    ;; finalization
    (setf h1 (logxor h1 len)) 
    (setf h2 (logxor h2 len)) 
    (setf h3 (logxor h3 len)) 
    (setf h4 (logxor h4 len)) 
    (setf h1 (mod (+ h1 h2 h3 h4) #16r100000000))
    (setf h2 (mod (+ h2 h1) #16r100000000))
    (setf h3 (mod (+ h3 h1) #16r100000000))
    (setf h4 (mod (+ h4 h1) #16r100000000))
    (setf h1 (fmix32 h1))
    (setf h2 (fmix32 h2))
    (setf h3 (fmix32 h3))
    (setf h4 (fmix32 h4))
    (setf h1 (mod (+ h1 h2 h3 h4) #16r100000000))
    (setf h2 (mod (+ h2 h1) #16r100000000))
    (setf h3 (mod (+ h3 h1) #16r100000000))
    (setf h4 (mod (+ h4 h1) #16r100000000))
    (+ (ash h1 96)
       (ash h2 64)
       (ash h3 32)
       h4)
    ))

(defun murmur3-x64-128 (data seed)
  (declare (list data)
           ((unsigned-byte 32) seed))
  (let ((h1 seed)
        (h2 seed)
        (c1 #16r87c37b91114253d5)
        (c2 #16r4cf5ad432745937f)
        (nblock (floor (/ (length data) 16)))
        (len (length data))
        )
    (declare ((unsigned-byte 64) h1 h2))
    ;; body
    (loop for i from 0 to (- nblock 1)
          do(let ((k1 (eightbytes data (* 16 i)))
                  (k2 (eightbytes data (+ (* 16 i) 8))))
              (setf k1 (rotl64 (mod (* k1 c1) #16r10000000000000000) 31))
              (setf k1 (mod (* k1 c2) #16r10000000000000000))
              (setf h1 (rotl64 (logxor h1 k1) 27))
              (setf h1 (mod (+ h1 h2) #16r10000000000000000))
              (setf h1 (mod (+ (* h1 5) #16r52dce729) #16r10000000000000000))

              (setf k2 (rotl64 (mod (* k2 c2) #16r10000000000000000) 33))
              (setf k2 (mod (* k2 c1) #16r10000000000000000))
              (setf h2 (rotl64 (logxor h2 k2) 31))
              (setf h2 (mod (+ h2 h1) #16r10000000000000000))
              (setf h2 (mod (+ (* h2 5) #16r38495ab5) #16r10000000000000000))))
    ;; tail
    (let ((k1 0)
          (k2 0)
          (nb (* nblock 16))
          (r (mod len 16)))
      (declare ((unsigned-byte 64) k1 k2))
      (when (= r 15)
        (setf k2 (ash (nth (+ nb 14) data) 48)))
      (when (>= r 14)
        (setf k2 (logxor k2 (ash (nth (+ nb 13) data) 40))))
      (when (>= r 13)
        (setf k2 (logxor k2 (ash (nth (+ nb 12) data) 32))))
      (when (>= r 12)
        (setf k2 (logxor k2 (ash (nth (+ nb 11) data) 24))))
      (when (>= r 11)
        (setf k2 (logxor k2 (ash (nth (+ nb 10) data) 16))))
      (when (>= r 10)
        (setf k2 (logxor k2 (ash (nth (+ nb 9) data) 8))))
      (when (>= r 9)
        (setf k2 (logxor k2 (nth (+ nb 8) data)))
        (setf k2 (mod (* k2 c2) #16r10000000000000000))
        (setf k2 (rotl64 k2 33))
        (setf k2 (mod (* k2 c1) #16r10000000000000000))
        (setf h2 (logxor h2 k2)))

      (when (>= r 8)
        (setf k1 (logxor k1 (ash (nth (+ nb 7) data) 56))))
      (when (>= r 7)
        (setf k1 (logxor k1 (ash (nth (+ nb 6) data) 48))))
      (when (>= r 6)
        (setf k1 (logxor k1 (ash (nth (+ nb 4) data) 40))))
      (when (>= r 5)
        (setf k1 (logxor k1 (ash (nth (+ nb 4) data) 32))))
      (when (>= r 4)
        (setf k1 (logxor k1 (ash (nth (+ nb 3) data) 24))))
      (when (>= r 3)
        (setf k1 (logxor k1 (ash (nth (+ nb 2) data) 16))))
      (when (>= r 2)
        (setf k1 (logxor k1 (ash (nth (+ nb 1) data) 8))))
      (when (>= r 1)
        (setf k1 (logxor k1 (nth nb data)))
        (setf k1 (mod (* k1 c1) #16r10000000000000000))
        (setf k1 (rotl64 k1 31))
        (setf k1 (mod (* k1 c2) #16r10000000000000000))
        (setf h1 (logxor h1 k1))))
    ;; finalization
    (setf h1 (logxor h1 len))
    (setf h2 (logxor h2 len))
    (setf h1 (mod (+ h1 h2) #16r10000000000000000))
    (setf h2 (mod (+ h2 h1) #16r10000000000000000))
    (setf h1 (fmix64 h1))
    (setf h2 (fmix64 h2))
    (setf h1 (mod (+ h1 h2) #16r10000000000000000))
    (setf h2 (mod (+ h2 h1) #16r10000000000000000))
    (+ (ash h1 64)
       h2)
    ))

;; (format t "~X   " (murmurhash-x86-32 '(65 66 67 68 69) 0))
;; (format t "~X   " (murmurhash-x86-128
;;                    '(65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81) 0))
;; (format t "~X" (murmurhash-x64-128
;;                 '(65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81) 0))

